home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / palette.cls < prev    next >
Text File  |  1997-06-14  |  8KB  |  254 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "CPalette"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = True
  10. Option Explicit
  11.  
  12. Implements ISubclass
  13.  
  14. Public Enum ECycleDirection2
  15.     ecdCycleLeft
  16.     ecdCycleRight
  17. End Enum
  18.  
  19. Private hPal As Long, hPalOld As Long
  20. Private hWnd As Long, hDC As Long, cPal As Long, cPalReal As Long
  21. Private iFrom As Long, iTo As Long
  22. Private ape() As PALETTEENTRY
  23. Private emr As EMsgResponse
  24.  
  25. Public Enum EErrorPalette
  26.     eeBasePalette = 13130   ' CPalette
  27.     eeInvalidPalette        ' Invalid palette
  28.     eePaletteNotInit        ' Palette not initialized with Create
  29.     eeBitmapNoPalette       ' Bitmap has no palette
  30.     eeInvalidExclusion      ' Invalid first or last index
  31.     eeCantResizeArray       ' Input array must be resizable
  32. End Enum
  33.  
  34. #If fComponent = 0 Then
  35. Private Sub ErrRaise(e As Long)
  36.     Dim sText As String, sSource As String
  37.     If e > 1000 Then
  38.         sSource = App.ExeName & ".CPalette"
  39.         Select Case e
  40.         Case eeBasePalette
  41.             BugAssert True
  42.         Case eeInvalidPalette
  43.             sText = "Invalid palette"
  44.         Case eePaletteNotInit
  45.             sText = "Palette not initialized with Create"
  46.         Case eeBitmapNoPalette
  47.             sText = "Bitmap has no palette"
  48.         Case eeInvalidExclusion
  49.             sText = "Invalid first or last index"
  50.         Case eeCantResizeArray
  51.             sText = "Input array must be resizable"
  52.         End Select
  53.         Err.Raise COMError(e), sSource, sText
  54.     Else
  55.         ' Raise standard Visual Basic error
  56.         sSource = App.ExeName & ".VBError"
  57.         Err.Raise e, sSource
  58.     End If
  59. End Sub
  60. #End If
  61.  
  62. Public Function Create(ByVal hPalA As Long, ByVal hWndA As Long, _
  63.                        aColors() As OLE_COLOR, _
  64.                        Optional FirstIndex As Long = 0, _
  65.                        Optional LastIndex As Long = -1) As Long
  66.                        
  67.     ' Must be a new palette handle and same old window
  68.     If hPalA = hNull Or hPalA = hInvalid Then ErrRaise eeBitmapNoPalette
  69.     If hWndA = hNull Then ApiRaise ERROR_INVALID_HANDLE
  70.     Destroy
  71.     ' Initialize members
  72.     hPalOld = hPalA
  73.     hPal = hNull
  74.     iFrom = 0
  75.     hWnd = hWndA
  76.     hDC = GetDC(hWnd)
  77.     ' Get the size
  78.     cPalReal = MPalTool.PalSize(hPalOld)
  79.     ' Dimension an array for the real palette
  80.     ReDim ape(0 To cPalReal - 1) As PALETTEENTRY
  81.     ' Create a dumplicate palette
  82.     hPal = MPalTool.DuplicatePalette(hPalOld)
  83.     If hPal = hNull Then ErrRaise eeInvalidPalette
  84.     ' Adjust the exclusions and calculate the excluded length
  85.     iFrom = FirstIndex
  86.     If LastIndex = -1 Then
  87.         iTo = cPalReal - iFrom - 1
  88.     Else
  89.         iTo = LastIndex
  90.     End If
  91.     If iFrom >= iTo Or iTo - iFrom + 1 > cPalReal Then
  92.         ErrRaise eeInvalidExclusion
  93.     End If
  94.     cPal = iTo - iFrom + 1
  95.     ' Get the palette entries, mark them reserved, and save result
  96.     Dim i As Long, c As Long
  97.     c = GetPaletteEntries(hPal, 0, cPalReal, ape(0))
  98.     BugAssert c = cPalReal
  99.     For i = iFrom To iTo
  100.         ape(i).peFlags = PC_RESERVED
  101.     Next
  102.     c = SetPaletteEntries(hPal, 0, cPalReal, ape(0))
  103.     BugAssert c = cPalReal
  104.     If c = 0 Then BugMessage "Fail SetPaletteEntries: " & Err.LastDllError
  105.     ' Realize this new palette
  106.     Realize
  107.     ' Initialize the user's work palette
  108.     On Error GoTo CreateFail
  109.     ReDim aColors(0 To cPal - 1) As OLE_COLOR
  110.     CopyMemory aColors(0), ape(iFrom), cPal * 4
  111.     ' Subclass window to handle palette messages
  112.     AttachMessage Me, hWnd, WM_PALETTECHANGED
  113.     AttachMessage Me, hWnd, WM_QUERYNEWPALETTE
  114.     ' Return real color count
  115.     Create = cPalReal
  116.     FirstIndex = iFrom
  117.     LastIndex = iTo
  118.     Exit Function
  119. CreateFail:
  120.     If Err <> 0 And Err.Number = eeArrayLocked Then
  121.         ErrRaise eeCantResizeArray
  122.     Else
  123.         Err.Raise Err.Number, Err.Source, Err.Description
  124.     End If
  125.     
  126. End Function
  127.  
  128. Public Function Destroy()
  129.     ' Detach messages, restore old palette, free the user's work array
  130.     DetachMessage Me, hWnd, WM_QUERYNEWPALETTE
  131.     DetachMessage Me, hWnd, WM_PALETTECHANGED
  132.     SelectPalette hDC, hPalOld, APIFALSE
  133.     Call RealizePalette(hDC)
  134.     hDC = ReleaseDC(hWnd, hDC)
  135.     Erase ape
  136.     hPal = 0
  137.     hDC = 0
  138.     hWnd = 0
  139.     cPal = 0
  140.     cPalReal = 0
  141. End Function
  142.  
  143. Private Sub Class_Initialize()
  144.     iTo = -1
  145.     iFrom = -1
  146. End Sub
  147.  
  148. Private Sub Class_Terminate()
  149.     ' Always destroy
  150.     Destroy
  151. End Sub
  152.  
  153. ' Our work palette
  154. Public Property Get Handle() As Long
  155.     Handle = hPal
  156. End Property
  157.  
  158. ' User's original palette
  159. Public Property Get SourceHandle() As Long
  160.     SourceHandle = hPalOld
  161. End Property
  162.  
  163. Public Property Get RGBColor(ByVal i As Long) As OLE_COLOR
  164.     RGBColor = PaletteColorFromEntry(ape(i))
  165. End Property
  166. Public Property Let RGBColor(ByVal i As Long, ByVal clr As OLE_COLOR)
  167.     If hPal = 0 Then ErrRaise eePaletteNotInit
  168.     Call PaletteColorToEntry(ape(i), clr)
  169. End Property
  170.  
  171. ' Size of our work palette
  172. Property Get Size() As Long
  173.     Size = cPal
  174. End Property
  175.  
  176. ' Size of user's original palette
  177. Property Get SourceSize() As Long
  178.     SourceSize = cPalReal
  179. End Property
  180.  
  181. Property Get PaletteColor(ByVal i As Long) As OLE_COLOR
  182.     PaletteColor = &H2000000 Or PaletteColorFromEntry(ape(i))
  183. End Property
  184.  
  185. ' Caller passes in a modified array to be written to the palette
  186. Sub ModifyPalette(aColors() As OLE_COLOR)
  187.     If hPal = 0 Then ErrRaise eePaletteNotInit
  188.     CopyMemory ape(iFrom), aColors(0), cPal * 4
  189.     Animate
  190. End Sub
  191.  
  192. ' Animate the modified palette
  193. Sub Animate()
  194.     If hPal = 0 Then ErrRaise eePaletteNotInit
  195.     Dim f As Long
  196.     f = AnimatePalette(hPal, iFrom, cPal, ape(iFrom))
  197.     If f = 0 Then BugMessage "Fail AnimatePalette: " & Err.LastDllError
  198. End Sub
  199.  
  200. ' Select our our palette and realize it into the system
  201. Private Sub Realize(Optional Background As Boolean = False)
  202.     If hPal = 0 Then ErrRaise eePaletteNotInit
  203.     Dim h As Long
  204.     h = SelectPalette(hDC, hPal, -Background)
  205.     If h Then BugMessage "Fail SelectPalette: " & Err.LastDllError
  206.     Dim c As Long
  207.     c = RealizePalette(hDC)
  208.     If c = GDI_ERROR Then BugMessage "Fail RealizePalette: " & Err.LastDllError
  209. End Sub
  210.  
  211. ' Implement ISubclass
  212.  
  213. Private Property Let ISubclass_MsgResponse(ByVal emrA As EMsgResponse)
  214.     emr = emrA
  215. End Property
  216.  
  217. Private Property Get ISubclass_MsgResponse() As EMsgResponse
  218.     ISubclass_MsgResponse = emr
  219. End Property
  220.  
  221. Private Function ISubclass_WindowProc(ByVal hWndA As Long, _
  222.                                       ByVal iMsg As Long, _
  223.                                       ByVal wParam As Long, _
  224.                                       ByVal lParam As Long) As Long
  225.     ' Handle message
  226.     Select Case iMsg
  227.     Case WM_PALETTECHANGED
  228.         ' Background
  229.         If wParam <> hWndA Then Realize False
  230.         emr = emrPostProcess
  231.     Case WM_QUERYNEWPALETTE
  232.         ' Foreground
  233.         Realize True
  234.         ISubclass_WindowProc = APITRUE
  235.         emr = emrConsume
  236.     End Select
  237. End Function
  238.  
  239. ' ---- Private Helpers ----
  240. '
  241. Private Function PaletteColorFromEntry(pe As PALETTEENTRY) As OLE_COLOR
  242.     ' Copy color bytes, ignore flag byte
  243.     CopyMemory PaletteColorFromEntry, pe, 3
  244. End Function
  245.  
  246. Private Sub PaletteColorToEntry(pe As PALETTEENTRY, ByVal clr As OLE_COLOR)
  247.     ' Copy color bytes, ignore flag byte
  248.     CopyMemory pe, clr, 3
  249. End Sub
  250.  
  251.  
  252.  
  253.  
  254.